Euroscene 1/Euroscene 1.iso/resource/midi2tex.lha/Midi2TeX/src/tp_m2tf2.pas

Pascal/Delphi Source File | 1992-07-28 | 8.9 KB | 331 lines

UNIT TP_M2TF2;

INTERFACE

uses TP_decl,TP_debug,TP_misc;


procedure ReadBlock(VAR FilRec : FileRecord);
Function ReadByte(VAR FilRec : FileRecord) : Byte;
Function ReadLongInt(VAR FilRec : FileRecord) : LongInt;
Function ReadInteger(VAR FilRec : FileRecord) : Integer;
Function ReadVarLen(VAR FilRec : FileRecord) : LONGINT;
Function ReadString(VAR FilRec : FileRecord;len : integer) : STRING;
Function GetFilePos(VAR FilRec : FileRecord) : LONGINT;
PROCEDURE SetFilePos(VAR FilRec : FileRecord;Pst : LONGINT);
Procedure C2Pstring(VAR Cstr : STRING);
Procedure P2Cstring(VAR Pstr : STRING);
Procedure InitFilRec(VAR FilRec : FileRecord);
Procedure KillFilRec(VAR FilRec : FileRecord);
Procedure RestoreLastRead(VAR FilRec : FileRecord);
IMPLEMENTATION


(**************************************************)
      procedure ReadBlock(VAR FilRec : FileRecord);
(**************************************************)
Begin
With FilRec Do
    Begin
    (* there is a request to read a block. If the EOF is reached exit *)
    If LastBlockRead Then ErrorExit(24);
    Seek(MidiFile,FilePosition);
    IF BufSemaphore>0 Then
         Begin
         Move(ReadBuf^[BufPoint],ReadBuf^[1],BufSemaphore);
         BufPoint:=BufSemaphore;
         End
    Else
         BufPoint:=1;

    BlockRead(MidiFile, ReadBuf^[BufPoint],BufSize-BufPoint+1,ReadIn);
    BufSemaphore:=BufSemaphore+ReadIn;
    If Debug Then WriteDebugInfo('Bufsemaphore : '+W2S(BufSemaphore));
    If ReadIn<(BufSize-BufPoint+1) Then
        Begin
        LastBlockRead:=TRUE;
        If Debug then WriteDebugInfo('Read in last block in file');
        End
    Else
        LastBlockRead:=FALSE;
    BufPoint:=1;
    FilePosition:=FilePos(MidiFile);
    End;
End; (* ReadBlock *)

(*************************************************)
    Function ReadByte(VAR FilRec : FileRecord) : Byte;
(*************************************************)
BEGIN
With FilRec Do
    Begin
    If BufSemaphore<1 Then ReadBlock(FilRec);
    ReadByte:=ReadBuf^[BufPoint];
    DEC(BufSemaphore);
    INC(BufPoint);
    INC(BytesProcessed);
    LastNoBytesRead:=1;
    If LastBlockRead AND (BufPoint=BufSemaphore) THEN
        BEGIN
        NoMoreData:=TRUE;
        If Debug then WriteDebugInfo('There are no more data');
        End
    Else
        NoMoreData:=FALSE;
    End;
END; (* ReadByte *)

{$IFDEF PC}
(*******************************************************)
    Function ReadLongInt(VAR FilRec : FileRecord) : LongInt;
(*******************************************************)
VAR  TmpLI : LongInt;
     cnt   : INTEGER;
     b     : Byte;
BEGIN
With FilRec Do
    Begin
    If BufSemaphore<4 Then ReadBlock(FilRec);
    TmpLI:=0;
    For cnt:=0 To 3 DO
        Begin
        Move(ReadBuf^[BufPoint+cnt],b,1);
        TmpLI:=256*TmpLI+b;
        End;
    INC(BufPoint,4);
    DEC(BufSemaphore,4);
    INC(BytesProcessed,4);
    LastNoBytesRead:=4;
    If LastBlockRead AND (BufPoint=BufSemaphore) THEN
        BEGIN
        NoMoreData:=TRUE;
        If Debug then WriteDebugInfo('There are no more data');
        End
    Else
        NoMoreData:=FALSE;
    ReadLongInt:=TmpLI;
    End;
END; (* ReadLongInt *)


(*******************************************************)
    Function ReadInteger(VAR FilRec : FileRecord) : Integer;
(*******************************************************)
VAR  TmpInt,
     cnt : Integer;
     b   : Byte;
BEGIN
With FilRec Do
    Begin
    If BufSemaphore<2 Then ReadBlock(FilRec);
    TmpInt:=0;
    For cnt:=0 To 1 Do
        Begin
        Move(ReadBuf^[BufPoint+cnt],b,1);
        TmpInt:=256*TmpInt+b;
        End;
    DEC(BufSemaphore,2);
    INC(BufPoint,2);
    INC(BytesProcessed,2);
    LastNoBytesRead:=2;
    If LastBlockRead AND (BufPoint=BufSemaphore) THEN
        BEGIN
        NoMoreData:=TRUE;
        If Debug then WriteDebugInfo('There are no more data');
        End
    Else
        NoMoreData:=FALSE;
    ReadInteger:=TmpInt;
    End;
END; (* ReadInteger *)
{$ENDIF}

{$IFDEF ST}
(*******************************************************)
    Function ReadInteger(VAR FilRec : FileRecord) : Integer;
(*******************************************************)
VAR  TmpInt : Integer;
BEGIN
With FilRec Do
    Begin
    If BufSemaphore<2 Then ReadBlock(FilRec);
    Move(ReadBuf^[BufPoint],TmpInt,2);
    DEC(BufSemaphore,2);
    INC(BufPoint,2);
    INC(BytesProcessed,2);
    LastNoBytesRead:=2;
    If LastBlockRead AND (BufPoint=BufSemaphore) THEN
        BEGIN
        NoMoreData:=TRUE;
        If Debug then WriteDebugInfo('There are no more data');
        End
    Else
        NoMoreData:=FALSE;
    ReadInteger:=TmpInt;
    End;
END; (* ReadInteger *)

(*******************************************************)
    Function ReadLongInt(VAR FilRec : FileRecord) : LongInt;
(*******************************************************)
VAR  TmpLI : LongInt;
BEGIN
With FilRec Do
    Begin
    If BufSemaphore<4 Then ReadBlock(FilRec);
    Move(ReadBuf^[BufPoint],TmpLI,4);
    INC(BufPoint,4);
    DEC(BufSemaphore,4);
    INC(BytesProcessed,4);
    LastNoBytesRead:=4;
    If LastBlockRead AND (BufPoint=BufSemaphore) THEN
        BEGIN
        NoMoreData:=TRUE;
        If Debug then WriteDebugInfo('There are no more data');
        End
    Else
        NoMoreData:=FALSE;
    ReadLongInt:=TmpLI;
    End;
END; (* ReadLongInt *)
{$ENDIF}

(******************************************************)
    Function ReadVarLen(VAR FilRec : FileRecord) : LONGINT;
(******************************************************)
VAR Tmp : LONGINT;
    Bt  : Byte;
    Cnt : Byte;
BEGIN
Cnt:=1;
With FilRec DO
    Begin
    tmp:=0;
    Bt:=ReadByte(FilRec);

    If (Bt AND $80)>0 Then
       Begin
       Repeat
        Bt:=Bt and $7f;
        tmp:=tmp+Bt;
        tmp := tmp SHL 7;
        Bt:=ReadByte(FilRec);
        Inc(Cnt);
       Until (Bt AND $80)=0;
       tmp:=tmp+Bt;
       End
    Else
       tmp:=Bt;

    ReadVarLen:=tmp;
    LastNoBytesRead:=Cnt;
    End;
END; (* ReadVarLen *)

(*******************************************************************)
    Function ReadString(VAR FilRec : FileRecord;len : integer) : STRING;
(*******************************************************************)
VAR TmpStr : String[80];
BEGIN
With FilRec Do
    Begin
    If BufSemaphore<len Then ReadBlock(FilRec);
    TmpStr[0]:=Chr(len);
    Move(ReadBuf^[BufPoint],TmpStr[1],len);
    DEC(BufSemaphore,len);
    INC(BufPoint,len);
    INC(BytesProcessed,len);
    LastNoBytesRead:=len;
    If LastBlockRead AND (BufPoint=BufSemaphore) THEN
        BEGIN
        NoMoreData:=TRUE;
        If Debug then WriteDebugInfo('There are no more data');
        End
    Else
        NoMoreData:=FALSE;
    ReadString:=TmpStr;
    End;
END; (* ReadString *)

(********************************************)
    Procedure C2Pstring(VAR Cstr : STRING);
(********************************************)
VAR
   nilpos : BYTE;
BEGIN
 Cstr[0]:=#80;
 nilpos:=(pos(#00,Cstr));
 Cstr[0]:=Chr(nilpos);
End; (* C2Pstring *)

(********************************************)
    Procedure P2Cstring(VAR Pstr : STRING);
(********************************************)
VAR L : Byte;
BEGIN
L:=Length(Pstr);
Move(Pstr[1],Pstr[0],L);
Pstr[L]:=#00;
End; (* C2Pstring *)


(******************************************************)
    Function GetFilePos(VAR FilRec : FileRecord) : LONGINT;
(******************************************************)
Begin
With FilRec Do
     GetFilePos:=FilePos(MidiFile) div 500 + BufPoint-1;
End;

(************************************************************)
    PROCEDURE SetFilePos(VAR FilRec : FileRecord;Pst : LONGINT);
(************************************************************)
Begin
With FilRec Do
   Begin
   Seek(MidiFile,Pst);
   BufPoint:=BufSize;
   BufSemaPhore:=0;
   ReadBlock(FilRec);
   End;
End;

(************************************************************)
     Procedure InitFilRec(VAR FilRec : FileRecord);
(************************************************************)
Begin
FillChar(FilRec,SizeOf(FilRec),#0);
With FilRec Do
    Begin
    BufPoint:=BufSize;
    If MaxAvail>SizeOf(BufType) Then
        GetMem(ReadBuf,SizeOf(BufType))
    Else
        ErrorExit(9);
    End;
End;

(************************************************************)
     Procedure KillFilRec(VAR FilRec : FileRecord);
(************************************************************)
Begin
With FilRec Do
    Begin
    FreeMem(ReadBuf,SizeOf(BufType));
    End;
End;

(************************************************************)
  Procedure RestoreLastRead(VAR FilRec : FileRecord);
(************************************************************)
Begin
With FilRec Do
   Begin
   Dec(BufPoint,LastNoBytesRead);
   Dec(BytesProcessed,LastNoBytesRead);
   Inc(BufSemaphore,LastNoBytesRead);
   End
End;

BEGIN
END.